Tips&Tricks

I trucchi del mestiere

Come "ricercare" una finestra tra quelle aperte in Windows

Questa procedura permette di "ndare alla ricerca" patendo da una finestra base (per esempio quella di background di Windows il cui handle Φ facilmente ricavabile - attraverso l'utilizzo della API GetDesktopWindow (Public Declare Function GetDesktopWindow Lib "user32" Alias "GetDesktopWindow" () As Long), di una determinata finestra o sotto-finestra avente come caption il testo indicato come parametro di funzione.
In ambiente Windows XP se si cerca una finestra con captino "Start" si pu≥ ottenere l'handle del bottone "START" della barra di controllo; di conseguenza Φ possibile cambiare il testo in esso contenuto.
Tip fornito dal Sig. S.Tubini

Option explicit

Private Declare Function GetWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, 
ByVal wCmd As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Public Declare Function GetWindowTextLength Lib "user32" Alias 
"GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As 
Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As 
Long, ByVal lpString As String) As Long

Private Const GW_CHILD = 5
Private Const GW_HWNDNEXT = 2

Public Function SearchWindow(hWnd As Long, sCaption As String) As Long
On Local Error Resume Next
Dim H1 As Long, T As String, T23 As String
 
 H1 = GetWindow(hWnd, GW_CHILD)
 If H1 = 0 Then Exit Function
 T = FindWindowsText(H1)

 If T = sCaption Then
    SearchWindow = H1: Exit Function
 End If
 
 If GetWindow(H1, GW_CHILD) > 0 Then
   SearchWindow = SearchWindow(H1, sCaption)
   If SearchWindow <> 0 Then Exit Function
 End If
 
    Do
     H1 = GetWindow(H1, GW_HWNDNEXT)
     If H1 = 0 Then Exit Function
     T = FindWindowsText(H1)
     If T = sCaption Then
        SearchWindow = H1: Exit Function
     End If
        If GetWindow(H1, GW_CHILD) > 0 Then
            SearchWindow = SearchWindow(H1, sCaption)
            If SearchWindow <> 0 Then Exit Function
        End If
    Loop Until H1 = 0
End Function

Public Function FindWindowsText(hWnd As Long) As String
    FindWindowsText = String$(GetWindowTextLength(hWnd) + 1, vbNull)
    GetWindowText hWnd, FindWindowsText, Len(FindWindowsText)
    FindWindowsText = Left(FindWindowsText, lstrlen(FindWindowsText))
End Function

Public Function ChangeWindowsCaption (hWnd As Long,sTxt As String)
SetWindowText hWnd, sTxt
End Function

Un conto alla rovescia per arrestare il sistema

Un tip per spegnere il computer dopo un determinato periodo di tempo. In caso di chiusura del programma, esso risponderα come se il tempo fosse scaduto.
Per il corretto funzionamento si consiglia di inizializzare i due controlli timer con i seguenti valori di proprietα:

Timer_tempo α Intervallo 1000 / Enabled = False
Timer_controllo α Intervallo 200 / Enabled = True

Tip fornito dal Sig. M. Bruseghin

Private Sub Timer_tempo_Timer()
If lblTempos.Caption = 0 And lblTempom.Caption = 0 And lblTempoh.Caption = 0 Then
   Timer_tempo.Enabled = False
Else
   lblTempos.Caption = lblTempos.Caption - 1
End If

If lblTempos.Caption < 0 Then
   lblTempom.Caption = lblTempom.Caption - 1
   lblTempos.Caption = 59
End If

If lblTempom.Caption < 0 Then
   lblTempoh.Caption = lblTempoh.Caption - 1
   lblTempom.Caption = 59
End If

If lblTempoh.Caption < 0 Then
   lblTempoh.Caption = 0
   lblTempom.Caption = 59
End If

If lblTempoh.Caption = 0 Then
   lblTempoh.Caption = 0
End If

If lblTempos.Caption = 0 Then
   If lblTempom.Caption = 0 Then
      If lblTempoh.Caption = 0 Then
         Timer_tempo.Enabled = False
         Form1.Show
		 MsgBox "Tempo scaduto!", vbOKOnly + vbExclamation, "Arresto sistema in corsoà"
		 ' per Windows 98
		 Shell ("C:\WINDOWS\RUNDLL.EXE user.exe,exitwindows")
		 'per Windows XP
		 Shell ("C:\WINDOWS\RUNDLL32.EXE user,exitwindows")
	  	 End
   	  End If
   End If
End If
End Sub

Private Sub Timer_controllo_Timer()
   If lblTempos.Caption = 0 And lblTempom.Caption = 0 And lblTempoh.Caption = 0 Then
      cmdAccendi.Enabled = False
   Else
      If Timer_tempo.Enabled = False Then
         cmdAccendi.Enabled = True
	  End If
   End If
End Sub

'codice dei vari CommandButton
Private Sub cmdAccendi_Click()
	Timer_tempo.Enabled = True
	cmdAccendi.Enabled = False
End Sub

Private Sub cmdStop_Click()
	Timer_tempo.Enabled = False
	If lblTempoh.Caption = 0 And lblTempom.Caption = 0 And lblTempos.Caption = 0 Then
		cmdAccendi.Enabled = False
	Else
		cmdAccendi.Enabled = True
	End If
End Sub

Private Sub cmdImpostaTime_Click()
	If Timer_tempo.Enabled = False Then
		cmdAccendi.Enabled = False
	End If

	If txtOra.Text > "24" Then
		MsgBox "Il Timer dell'ora non Φ accettabile", vbOKOnly + vbCritical, "Errore MB 
		TimeOut! 1.0"
		txtOra.Text = ""
		txtOra.SetFocus
	Else
		lblTempoh.Caption = txtOra.Text
	End If

	If txtMinuti.Text > "59" Then
		MsgBox "Il Timer dei minuti non Φ accettabile", vbOKOnly + vbCritical, "Errore MB 
		TimeOut! 1.0"
		txtMinuti.Text = ""
		txtMinuti.SetFocus
	Else
		lblTempom.Caption = txtMinuti.Text
	End If

	If txtSecondi.Text > "59" Then
		MsgBox "Il Timer dei secondi non Φ accettabile", vbOKOnly + vbCritical, "Errore MB 
		TimeOut! 1.0"
		txtSecondi.Text = ""
		txtSecondi.SetFocus
	Else
		lblTempos.Caption = txtSecondi.Text
	End If

	If txtOra.Text = "" Then
		lblTempoh.Caption = 0
	End If

	If txtMinuti.Text = "" Then
		lblTempom.Caption = 0
	End If
	If txtSecondi.Text = "" Then
		lblTempos.Caption = 0
	End If
End Sub

Private Sub optImpostazioni_Click()
	txtOra.Enabled = False
	txtMinuti.Enabled = False
	txtSecondi.Enabled = False
	cmdImpostaTime.Enabled = False
	cmdStop.Enabled = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
	MsgBox "Chiusura non consentita", vbOKOnly + vbCritical, "Arresto sistema in corso..."
	' per Windows 98
	Shell ("C:\WINDOWS\RUNDLL.EXE user.exe,exitwindows")
	'per Windows XP
	Shell ("C:\WINDOWS\RUNDLL32.EXE user,exitwindows")
	End
End Sub

Come copiare una lista di IP in un vettore

Spesso su internet si trovano lunghissime liste di IP (Internet Protocol). Volendo creare un programma per gestire tali indirizzi Φ comodo averli sotto forma di vettori.
Il tip proposto prende in considerazione gli ip nella forma: 255.255.255.255:8080 prelevati da un controllo textbox e poi spezzettati in due array semplici: ip() e port().
Tip fornito dal Sig. S. Rinaldo

Private Sub Command1_Click()
    
    Dim temp() As String
    Dim ip()
    Dim port()
    Dim fine As Integer
    Dim i, j As Integer
    
    temp = Split(txtIP.Text, vbCrLf)
    j = -1
    
    For i = LBound(temp) To UBound(temp)
        fine = InStr(1, temp(i), ":")
        If ((fine > 7) And (fine < 17)) Then
            j = j + 1
            ReDim Preserve ip(j)
            ReDim Preserve port(j)
            
            ip(i) = Mid(temp(i), 1, fine - 1)
            port(i) = Mid(temp(i), fine + 1, Len(temp(i)))
        End If
    Next i
End Sub

Un semplice Server proxy

Una semplice applicazione che funge da Server Proxy consentendo la condivisione e l'accesso ai documenti ipertestuali del WEB tra tutti i computer di una rete locale.
Per poterlo utilizzare, all'interno del browser digitare: "http://IP_PROXY:8080/IPSERVER/pagina.htm
Tip fornito dal Sig. M.Nicosia

Option Explicit
Dim i As Integer

Private Sub delay(interval As Single)
	Dim s As Single
	s = Timer
	Do While Timer < (s + interval)
	    DoEvents
	Loop
End Sub

Private Sub parse(buffer As String, ByRef server As String, ByRef richiesta As String)
	On Error Resume Next
	Dim url As String
	url = Left$(buffer, InStr(buffer, "HTTP/1.1") - 2)
	url = Right$(url, Len(url) - 5)
	If InStr(url, "/") = 0 Then
 	   server = url
	    richiesta = "GET /"
	Else
	    server = Left$(url, InStr(url, "/") - 1)
	    richiesta = "GET " & Right$(url, Len(url) - Len(server)) & vbCrLf
	End If
End Sub

Private Sub Form_Load()
	wskserver.LocalPort = 8080
	wskserver.Listen
	i = 0
End Sub

Private Sub wskconnect_DataArrival(Index As Integer, ByVal bytesTotal As Long)
	On Error Resume Next
	Dim buffer As String
	Dim server As String
	Dim richiesta As String
	wskconnect(Index).GetData buffer
	parse buffer, server, richiesta
	Load wskweb(Index)
	wskweb(Index).Connect server, 80
	delay 1
	wskweb(Index).SendData richiesta
End Sub

Private Sub wskconnect_SendComplete(Index As Integer)
	wskconnect(Index).Close
	wskweb(Index).Close
	Unload wskconnect(Index)
	Unload wskweb(Index)
End Sub

Private Sub wskserver_ConnectionRequest(ByVal requestID As Long)
	i = i + 1
	Load wskconnect(i)
	wskconnect(i).Accept requestID
	delay 1
End Sub

Private Sub wskweb_DataArrival(Index As Integer, ByVal bytesTotal As Long)
	On Error Resume Next
	Dim risposta As String
	wskweb(Index).GetData risposta
	wskconnect(Index).SendData risposta
End Sub

Come calcolare il crc32 di alcune tipologie di dati

La semplice applicazione Visual Basic permette di calcolare il CRC32 di una stringa, di una array di byte o di un file.
Ricordiamo che il controllo del CRC32 consente, mediante una tecnica di codifica dei bit, di ottenere un elevato grado di protezione del messaggio in oggetto, grazie alla rilevazione di un'alta percentuale d'errori
Tip fornito dal Sig. S.Tubini

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, 
Source As Any, ByVal Length As Long)

Private crc32table(255) As Long
Private Crc32TableSet As Boolean

Public Sub CreateTable(Optional lPolinomio As Long = &HEDB88320)
  Dim I     As Long
  Dim j     As Long
  Dim lCrc  As Long
  
  For I = 1 To 255 Step 1
    lCrc = I
    j = 8
    For j = 1 To 8 Step 1
      If (lCrc And 1) Then
        lCrc = ((lCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF

        lCrc = lCrc Xor lPolinomio
      Else
        lCrc = ((lCrc And &HFFFFFFFE) \ 2&) And &H7FFFFFFF

      End If
    Next
    crc32table(I) = lCrc
Next I
Crc32TableSet = True
End Sub

Public Function CalcCRC32(ByteArr() As Byte) As Long
  Dim I As Long
  Dim CRC32Val As Long
  Dim ArrLen As Long
  Dim LongBytes(3) As Byte
  If (Not Crc32TableSet) Then CreateTable
  CRC32Val = -1
  ArrLen = UBound(ByteArr())
  For I = 0 To ArrLen Step 1
      SplitLongValues CRC32Val, LongBytes(): LongBytes(3) = 0
      CRC32Val = crc32table((CRC32Val Xor ByteArr(I)) And &HFF)
      CRC32Val = CRC32Val Xor MergeLongValues(LongBytes())
  Next
  
  CalcCRC32 = CRC32Val
End Function

Public Function CalcCRC32FromString(sStr As String) As Long
Dim bArr() As Byte, I As Long

    If Len(sStr) > 0 Then
        ReDim bArr(0 To (Len(sStr) - 1)) As Byte
        For I = 1 To Len(sStr) Step 1
            bArr(I - 1) = Asc(Mid(sStr, I, 1))
        Next
         CalcCRC32FromString = CalcCRC32(bArr())
    End If
    
End Function

Public Function CalcCRC32FromFile(sFile As String) As Long
On Local Error Resume Next
Dim bArr() As Byte, I As Long, L As Long
    If FileLen(sFile) > 0 Then
        If Err <> 0 Then Err = 0: Exit Function
        ReDim bArr(0 To (FileLen(sFile) - 1)) As Byte
        L = FreeFile()
        Open sFile For Binary As L
            Get L, , bArr()
        Close L
        CalcCRC32FromFile = CalcCRC32(bArr())
    End If
End Function

Public Sub SplitLongValues(lValue As Long, ByteArr() As Byte)
   CopyMemory ByteArr(0), lValue, 4
End Sub

Public Sub SplitIntegerValues(iValue As Integer, ByteArr() As Byte)
    CopyMemory ByteArr(0), lValue, 2
End Sub

Public Function MergeLongValues(ByteArr() As Byte) As Long
    CopyMemory MergeLongValues, ByteArr(0), 4
End Function

Public Function MergeIntegerValues(ByteArr() As Byte) As Integer
    CopyMemory MergeIntegerValues, ByteArr(0), 2
End Function